SPACE 1/SPACE - Library 1 - Volume 1.iso/program/363/tprolog1/monitor.pro

Text File | 1987-09-03 | 45KB | 1,126 lines

%                    TOY - the Prolog part.
% (c) Copyright 1983 - Feliks Kluzniak, Stanislaw Spakowicz
%           Institute of Informatics, Warsaw University.
%
%         ATARI ST Implementation (c) Jens J. Kilian, THD
%
% ::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
% - - - - - -          INTERACTIVE DRIVER - TOP LEVEL          - - - - - -
% ::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

ear :- nl, display('TOY Prolog listening:'), nl, tag(loop).
ear :- grf_mode, halt('TOY Prolog --- end of session.').

loop :- repeat,
        display(?-), read(Term, Sym_tab), exec(Term, Sym_tab), fail.

stop :- tagfail(loop).
sysload(File) :- see(File), tagexit(loop).

exec('e r r', _) :- !.           % this covers variables, too
exec(:-(Goals), _) :- !, once(Goals).
exec(N, _) :- integer(N), !, num_clause.

% assert non-unit clauses or grammar rules entered OUTSIDE 'consult' mode

exec(:-(Head, Body), _) :- !, assimilate(:-(Head, Body)),   % cf. consult
      display(ok), nl.
exec(-->(Left, Right), _) :- !, assimilate(-->(Left, Right)),
      display(ok), nl.

% process a list of file names

exec([H | T], _) :- !, consultall([H | T]).

% normal execution

exec(Goals, Sym_tab) :-
      call(Goals), numbervars(Goals, 0, _),
      printvars(Sym_tab), enough(Sym_tab), !.
exec(_, _) :- display(no), nl.      % if call(Goals) fails

enough(Sym_tab) :- var(Sym_tab), !.
enough(_) :- rch, skipbl, lastch(Ch), rch, not(=(Ch, ';')).

printvars(Sym_tab) :- var(Sym_tab), display(yes), nl, !.
printvars(Sym_tab) :- prvars(Sym_tab).

prvars(Sym_tab) :- var(Sym_tab), !.
prvars([var(NameString, Instance) | Sym_tab_tail]) :-
      nl, writetext(NameString), display(' = '),
      side_effects(outt(Instance, fd(_, _), q)), wch(' '),
            % this is equivalent to writeq(Instance), but we avoid
            % superfluous calls to numbervars - cf. write
      prvars(Sym_tab_tail).

num_clause :- display('A number can''t be a clause.'), nl.

% read a program terminated by 'end.'  (NOT the only way to define user
% procedures, cf. exec); consult/reconsult must be issued from the terminal,
% and it returns there ( consult(user) is correct, too)

consultall([]) :- !.
consultall([-(Name) | OtherNames]) :-
      !, reconsult(Name), consultall(OtherNames).
consultall([Name | OtherNames]) :-
      !, consult(Name), consultall(OtherNames).

consult(File) :- seeing(OldF), readprog(File), see(OldF).
reconsult(File) :-
      redefine, seeing(OldF), readprog(File), see(OldF), redefine.
readprog(user) :- !, getprog.
readprog(File) :- see(File), echo, getprog, noecho, seen.

% the actual job is done by this procedure :
getprog :- repeat, read(T), assimilate(T), =(T, end), !.

assimilate('e r r') :- !.     % a variable is erroneous, too
assimilate( -->(Left, Right) ) :-
      !, tag(transl_rule(Left, Right, Clause)), assertz(Clause).
assimilate( :-(Goal) ) :- !, once(Goal).
assimilate(end) :- nl, !.
assimilate(N) :- integer(N), !, num_clause.
% otherwise store the Clause :
assimilate(Clause) :- assertz(Clause).


% ::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
% - - - - - -                  READ A TERM                     - - - - - -
% ::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

read(T) :- read(T, Sym_tab).
read(T, Sym_tab) :-
      gettr(T_internal, Sym_tab), !, maketerm(T_internal, T).
% if gettr fails, then ...
read('e r r', _) :-
      nl, display('+++ Bad term on input. Text skipped: '), skip, nl.

% skip to the nearest full stop not in quotes or in comment
skip :- lastch(Ch), wch(Ch), skip(Ch).

skip(.)   :- rch, lastch(Ch), e_skip(Ch), !.
skip('%') :- skip_comment, !, rch, skip.
skip(Q)   :- isquote(Q), skip_s(Q), !, rch, skip.
skip(_)   :- rch, skip.

% stop on a "layout" character
e_skip(Ch) :- @=<(Ch, ' ').
e_skip(Ch) :- wch(Ch), rch, skip.

skip_comment :- repeat, rch, lastch(Ch), wch(Ch), iseoln(Ch), !.

isquote('''').       isquote('"').

% skip a string
skip_s(Quote) :- repeat, rch, lastch(Ch), wch(Ch), =(Ch, Quote), !.

% ::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
% - - - - - -                    P A R S E R                   - - - - - -
% ::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
% This is an operator precedence parser for Prolog-10.  g e t t r
% constructs the internal representation of a term. next, m a k e t e r m
% constructs the term proper - see  r e a d. Here is an informal
% description of the underlying operator precedence grammar (each "rule"
% corrensponds to one clause of  r e d u c e). Sides are separated by ==>
% and multiple righthand sides - by OR.
%     t  ==>  variable   OR   integer   OR   string
%     t  ==>  identifier
%     t  ==>  identifier ( t )
%     t  ==>  []   OR   {}
%     t  ==>  ( t )   OR   [ t ]   OR   { t }
%     t  ==>  [ t | t ]
%     t  ==>  t postfix_functor
%     t  ==>  t infix_functor t
%     t  ==>  prefix_functor t
% Sequences of terms separated by commas - in rules 3, 5, 6 - will be recognised
% as comma-terms (commas are infix functors, covered by rule 8).
% There are five types of operators: vns(_), id(_), ff(_, _, _),
% br(_, _), bar - see the scanner. The terminal symbol dot never gets onto
% the stack. The terminal symbol bottom is never returned by the scanner;
% it is only used to initiate and terminate the main loop (p a r s e). The
% only nonterminal symbol is t(_).
% There are fives types of internal representations (Args denotes the represen-
% tation of arguments - usually a comma-term):
%     tr(Name, Args)       - for functor-terms,
%     arg0(X)              - for X a variable, an atom, a number, or a string,
%     bar(X, Y)            - for a list with front X and tail Y,
%     tr1(Name, X)         - for prefix and postfix functors,
%     tr2(Name, X, Y)      - for infix functors.
% A Name in tr may be a bracket type. See  r e d u c e (clauses 5, 6)
% and  m a k e t e r m  for details.

% - - - get the internal representation of a term
gettr(X, Sym_tab) :-
      gettoken(T, Sym_tab), parse([bottom], T, X, Sym_tab).

% p a r s e  takes four parameters: the current stack, the current token
% from input, the variable that drifts down and brings the internal repre-
% sentation to the surface, and the symbol table (used by  g e t t o k e n).
parse([t(X), bottom], dot, X, _) :- !.
parse(Stack, Input, X, Sym_tab) :-
      topterminal(Stack, Top, Pos),
      establish_precedence(Top, Input, Pos, Rel, RTop, RInput),
      exch_top(Top, RTop, Stack, RStack),
      step(Rel, RInput, RStack, NewStack, NewInput, Sym_tab),
      parse(NewStack, NewInput, X, Sym_tab).

% the topmost terminal will be covered by at most one nonterminal
% (the third parameter gives Top's position: 1 on the top, 2 covered)
topterminal([t(_), Top | _], Top, 2) :- !.
topterminal([Top | _], Top, 1).

% exchange the topmost terminal (applies only to disambiguated mixed functors)
exch_top(Top, Top, Stack, Stack) :- !.
exch_top(_, RTop, [t(X), _ | S], [t(X), RTop | S]) :- !.
exch_top(_, RTop, [_ | S], [RTop | S]).

% - - - perform one step: shift (stack the current token) or reduce
step(lseq, RInput, Stack, [RInput | Stack], NewInput, Sym_tab) :-
      !, gettoken(NewInput, Sym_tab).
step(gt, RInput, Stack, NewStack, RInput, _) :-
      reduce(Stack, NewStack).
% fail if reduction impossible (parse and gettr will fail, too -
% this failure will be intercepted by gettr's caller)

%reduce top segment of the stack according to the underlying grammar
reduce([ vns(X) | S], [t(arg0(X)) | S]).
reduce([  id(I) | S], [t(arg0(I)) | S]).
reduce([ br(r, '()'), t(X), br(l, '()'), id(I) | S],
                                  [t(tr(I, X)) | S]).
reduce([br(r, Type), br(l, Type) | S],
                  [t(arg0(Type)) | S]) :- not(=(Type, '()')).
                  % '[]' or '{}', see p, 2nd clause
reduce([br(r, Type), t(X), br(l, Type) | S],
                       [t(tr(Type, X)) | S]).
reduce([br(r, '[]'), t(Y), bar, t(X), br(l, '[]') | S],
                                    [t(bar(X, Y)) | S]).
reduce([ff(I, Type, _), t(X) | S],
               [t(tr1(I, X)) | S]) :- ismpostf(Type).
reduce([t(Y), ff(I, Type, _), t(X) | S],
                  [t(tr2(I, X, Y)) | S]) :- isminf(Type).
reduce([t(X), ff(I, Type, _) | S],
               [t(tr1(I, X)) | S]) :- ismpref(Type).
% otherwise fail (cf. step)

% - - - auxiliary tests for the parser
ispref(fy).       ispref(fx).

ispostf(yf).      ispostf(xf).

ismpref([TUn]) :- ispref(TUn).
ismpref([_, TUn]) :- ispref(TUn).

isminf([TBin]) :- member(TBin, [yfy, xfy, yfx, xfx]).
isminf([_, _]).

ismpostf([TUn]) :- ispostf(TUn).
ismpostf([_, TUn]) :- ispostf(TUn).

% - - - establish precedence relation between the topmost
% terminal on the stack and the current input terminal
establish_precedence(Top, Input, Pos, Rel, RTop, RInput) :-
      p(Top, Input, Pos, Rel0),
      finalize(Rel0, Top, Input, Rel, RTop, RInput), !.

finalize(lseq, Top, Input, lseq, Top, Input).
finalize(gt, Top, Input, gt, Top, Input).
finalize(lseq(RTop, RInput), _, _, lseq, RTop, RInput).
finalize(gt(RTop, RInput), _, _, gt, RTop, RInput).

p(id(_), br(l, '()'), 1, lseq).
p(br(l, Type), br(r, Type), _, lseq).
p(br(l, '[]'), bar, 2, lseq).
p(bar, br(r, '[]'), 2, lseq).

p(Top, Input, 1, gt) :-
      vns_id_br(Top, r), br_bar(Input, r).
p(Top, ff(N, Types, P), 1, gt(Top, ff(N, RTypes, P))) :-
      vns_id_br(Top, r), restrict(Types, [fx, fy], RTypes).
p(Top, Input, 1, lseq) :-
      br_bar(Top, l), vns_id_br(Input, l).
p(Top, ff(N, Types, P), Pos, lseq(Top, ff(N, RTypes, P))) :-
      br_bar(Top, l), pre_inpost(Pos, Types, RTypes).
p(ff(N, Types, P), Input, Pos, gt(ff(N, RTypes, P), Input)) :-
      br_bar(Input, r), post_inpre(Pos, Types, RTypes).
p(ff(N, Types, P), Input, 1, lseq(ff(N, RTypes, P), Input)) :-
      vns_id_br(Input, l), restrict(Types, [xf, yf], RTypes).

% functors with equal priorities
p(ff(NTop, TsTop, P), ff(NInp, TsInp, P), Pos, Rel) :-
      res_confl(TsTop, TsInp, Pos, RTsTop, RTsInp, Rel0),
      !, do_rel(Rel0, ff(NTop, RTsTop, P), ff(NInp, RTsInp, P), Rel).
% different priorities
p(ff(NTop, TsTop, PTop), ff(NInp, TsInp, PInp), Pos,
            gt(ff(NTop, RTsTop, PTop), ff(NInp, RTsInp, PInp))) :-
      stronger(PTop, PInp), !,
      restrict(TsInp, [fx, fy], RTsInp),
      post_inpre(Pos, TsTop, RTsTop).
p(ff(NTop, TsTop, PTop), ff(NInp, TsInp, PInp), Pos,
          lseq(ff(NTop, RTsTop, PTop), ff(NInp, RTsInp, PInp))) :-
      stronger(PInp, PTop), !,
      restrict(TsTop, [xf, yf], RTsTop),
      pre_inpost(Pos, TsInp, RTsInp).

p(_, dot, _, gt).
p(bottom, _, _, lseq).
% otherwise fail (p a r s e  fails, too)

vns_id_br(vns(_), _).
vns_id_br(id(_), _).
vns_id_br(br(LeftRight, _), LeftRight).

br_bar(br(LeftRight, _), LeftRight).
br_bar(bar, _).

stronger(Prior1, Prior2) :- less(Prior1, Prior2).

pre_inpost(1, Types, RTypes) :-              % the functor must be prefix
      restrict(Types, [xf, yf], A),
      restrict(A, [xfy, yfx, xfx], RTypes).
pre_inpost(2, Types, RTypes) :-              % the functor must not be prefix
      restrict(Types, [fx, fy], RTypes).

post_inpre(1, Types, RTypes) :-              % the functor must be postfix
      restrict(Types, [fx, fy], A),
      restrict(A, [xfy, yfx, xfx], RTypes).
post_inpre(2, Types, RTypes) :-              % the functor must not be postfix
      restrict(Types, [xf, yf], RTypes).

% leave only those types that do not belong to RSet,
% fail if this would leave no types at all (RSet contains
% only binary types, or only unary types)
restrict([T], RSet, [T]) :- !, not(member(T, RSet)).
restrict([TBin, TUn], RSet, [TBin]) :- member(TUn, RSet), !.
restrict([TBin, TUn], RSet, [TUn])  :- member(TBin, RSet), !.
restrict(Types, _, Types).

% compute relation for two functors with equal priorities; four cases:
%    both normal, Top mixed, Input mixed, both mixed
res_confl([TTop], [TInp], Pos, [TTop], [TInp], Rel0) :-
      !, ff_p(TTop, TInp, Pos, Rel0).
res_confl([TTopBin, TTopUn], [TInp], Pos, RTsTop, [TInp], Rel0) :-
      !, ff_p(TTopBin, TInp, Pos, RelB),
      ff_p(TTopUn, TInp, Pos, RelU),
      match_rels(RelB, RelU, Rel0, TTopBin, TTopUn, RTsTop).
res_confl([TTop], [TInpBin, TInpUn], Pos, [TTop], RTsInp, Rel0) :-
      !, ff_p(TTop, TInpBin, Pos, RelB),
      ff_p(TTop, TInpUn, Pos, RelU),
      match_rels(RelB, RelU, Rel0, TInpBin, TInpUn, RTsInp).
res_confl([TTopBin, TTopUn], [TInpBin, TInpUn], Pos, RTsTop, RTsInp, Rel0) :-
      ff_p(TTopBin, TInpBin, Pos, RelBB),
      ff_p(TTopBin, TInpUn, Pos, RelBU),
      ff_p(TTopUn, TInpBin, Pos, RelUB),
      ff_p(TTopUn, TInpUn, Pos, RelUU),
      res_mixed(RelBB, RelBU, RelUB, RelUU, Rel0,
                TTopBin, TTopUn, TInpBin, TInpUn, RTsTop, RTsInp), !.

do_rel(lseq, TopF, InpF, lseq(TopF, InpF)).
do_rel(gt, TopF, InpF, gt(TopF, InpF)).
% fail if Rel0 = err

match_rels(Rel, Rel, Rel, TBin, TUn, [TBin, TUn]) :- !.     % err included
match_rels(err, Rel, Rel, _, TUn, [TUn]) :- !.
match_rels(Rel, err, Rel, TBin, _, [TBin]) :- !.
match_rels(_, _, err, TBin, TUn, [TBin, TUn]).

res_mixed(Rel0, Rel0, Rel0, Rel0, Rel0,
            TTopBin, TTopUn, TInpBin, TInpUn,
            [TTopBin, TTopUn], [TInpBin, TInpUn]).
res_mixed(err, err, RelUB, RelUU, Rel0,
            _, TTopUn, TInpBin, TInpUn, [TTopUn], RTsInp) :-
      match_rels(RelUB, RelUU, Rel0, TInpBin, TInpUn, RTsInp).
res_mixed(RelBB, RelBU, err, err, Rel0,
            TTopBin, _, TInpBin, TInpUn, [TTopBin], RTsInp) :-
      match_rels(RelBB, RelBU, Rel0, TInpBin, TInpUn, RTsInp).
res_mixed(err, RelBU, err, RelUU, Rel0,
            TTopBin, TTopUn, _, TInpUn, RTsTop, [TInpUn]) :-
      match_rels(RelBU, RelUU, Rel0, TTopBin, TTopUn, RTsTop).
res_mixed(RelBB, err, RelUB, err, Rel0,
            TTopBin, TTopUn, TInpBin, _, RTsTop, [TInpBin]) :-
      match_rels(RelBB, RelUB, Rel0, TTopBin, TTopUn, RTsTop).
res_mixed(_, _, _, _, err, _, _, _, _, _, _).

% establish precedence relation for two (basic) types
ff_p(TTop, TInp, Pos, lseq) :-
      member(TTop, [xfy, fy]),      % right associative
      ff_p_aux1(Pos, TInp), !.
ff_p(TTop, TInp, Pos, gt) :-
      member(TInp, [yfx, yf]),      % left associative
      ff_p_aux2(Pos, TTop), !.
ff_p(_, _, _, err).

ff_p_aux1(1, TInp) :- ispref(TInp).
ff_p_aux1(2, TInp) :- member(TInp, [xfy, xf, xfx]).

ff_p_aux2(1, TTop) :- ispostf(TTop).
ff_p_aux2(2, TTop) :- member(TTop, [yfx, fx, xfx]).

% ::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
% - - - - - -         internal representation --> term         - - - - - -
% ::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

maketerm(arg0(X), X) :- !.          % variable, atom, number, string
maketerm(tr('()', RawTerm), T) :-
      !, maketerm(RawTerm, T).
maketerm(bar(RawList, RawTail), T) :-
      !, maketerm(RawTail, Tail),
      makelist(RawList, Tail, T).
maketerm(tr('[]', RawList), T) :-
      !, makelist(RawList, '[]', T).
maketerm(tr('{}', RawArg), '{}'(Arg)) :-
      !, maketerm(RawArg, Arg).
maketerm(tr(Name, RawArgs), T) :-
      !, makelist(RawArgs, '[]', Args),
      =..(T, [Name | Args]).
maketerm(tr2(Name, RawArg1, RawArg2), T) :-
      !, maketerm(RawArg1, Arg1), maketerm(RawArg2, Arg2),
      =..(T, [Name, Arg1, Arg2]).
maketerm(tr1(Name, RawArg), T) :-
      maketerm(RawArg, Arg), =..(T, [Name, Arg]).

% comma-term to dot-list-with-Tail
makelist(tr2(',', RawArg, RawArgs), Tail, [Arg | Args]) :-
      !, maketerm(RawArg, Arg), makelist(RawArgs, Tail, Args).
makelist(RawArg, Tail, [Arg | Tail]) :- maketerm(RawArg, Arg).

% ::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
% - - - - - -                   S C A N N E R                  - - - - - -
% ::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
% This scanner returns six kinds of tokens:
%        vns(_)                  variables, numbers, strings
%        id(Name)                atoms
%        ff(Name, Types, Prior)  "fix" functors
%        br(Which, Type)         brackets (left/right, '()' / '[]' / '{}')
%        bar                     |  (in lists)
%        dot                     . followed by a layout character

% - - - read a token and construct its internal form
% the input is supposed to be positioned
% over the first character of a token (or preceding "white space")
gettoken(Token, Sym_tab) :-
      skipbl, lastch(Startch), absorbtoken(Startch, Rawtoken), !,
      maketoken(Rawtoken, Token, Sym_tab), !.

% - - - read in a suitable sequence of characters
% a word, i.e. a regular alphanumeric identifier
absorbtoken(Ch, id([Ch | Wordtail])) :-
      wordstart(Ch), getword(Wordtail).
% a variable
absorbtoken(Ch, var([Ch | Tail])) :-
      varstart(Ch), getword(Tail).
% a solo character is a comma, a semicolon or an exclamation mark
absorbtoken(Ch, id([Ch])) :- solochar(Ch), rch.
% a bracket, i.e. ( ) [ ] { }
absorbtoken(Ch, br(Wh, Type)) :-
      bracket(Ch), bracket(Ch, Wh, Type), rch.
absorbtoken('|', bar) :- rch.
% a string in quotes or in double quotes
absorbtoken('''', qid(Qname)) :-
      rdch(Nextch), getstring('''', Nextch, Qname).
absorbtoken('"', str(String)) :-
      rdch(Nextch), getstring('"', Nextch, String).
% a positive number
absorbtoken(Ch, num([Ch | Digits])) :-
      digit(Ch), getdigits(Digits).
% a negative number or a dash (possibly starting a symbol, see below)
absorbtoken(-, Rawtoken) :- rdch(Ch), num_or_sym(Ch, Rawtoken).
absorbtoken(., Rawtoken) :- rdch(Ch), dot_or_sym(Ch, Rawtoken).
% a symbol, built of . : - < = > + / * ? & $ @ # ^ \
absorbtoken(Ch, id([Ch | Symbs])) :- symch(Ch), getsym(Symbs).
% an embedded comment
absorbtoken('%', Rawtoken) :-
      skipcomment, lastch(Ch), absorbtoken(Ch, Rawtoken).
% this shouldn't happen:
absorbtoken(Ch, _) :- display(errinscan(Ch)), nl, fail.

num_or_sym(Ch, num([-, Ch | Digits])) :-
      digit(Ch), getdigits(Digits).
num_or_sym(Ch, id([-, Ch | Symbs])) :- symch(Ch), getsym(Symbs).
num_or_sym(_, id([-])).

% layout characters precede ' ' in ASCII
dot_or_sym(Ch, dot) :- @=<(Ch, ' ').         % no advance
dot_or_sym(Ch, id([., Ch | Symbs])) :- symch(Ch), getsym(Symbs).
dot_or_sym(_, id([.])).

skipcomment :- lastch(Ch), iseoln(Ch), skipbl, !.
skipcomment :- rch, skipcomment.

% - - - auxiliary input procedures
% read an alphanumeric identifier
getword([Ch | Word]) :-
      rdch(Ch), alphanum(Ch), !, getword(Word).
getword([]).

% read a sequence of digits
getdigits([Ch | Digits]) :-
      rdch(Ch), digit(Ch), !, getdigits(Digits).
getdigits([]).

% read a symbol
getsym([Ch | Symbs]) :-
      rdch(Ch), symch(Ch), !, getsym(Symbs).
getsym([]).

% read a quoted id or string (Delim is either ' or ")
getstring(Delim, Delim, Str) :-
      !, rdch(Nextch), twodelims(Delim, Nextch, Str).
getstring(Delim, Ch, [Ch | Str]) :-
      rdch(Nextch), getstring(Delim, Nextch, Str).
twodelims(Delim, Delim, [Delim | Str]) :-
      !, rdch(Nextch), getstring(Delim, Nextch, Str).
twodelims(_, _, []).    % close the list

% auxiliary tests
wordstart(Ch) :- smalletter(Ch).
varstart(Ch) :- bigletter(Ch).
varstart('_').
bracket('(', l, '()').           bracket(')', r, '()').
bracket('[', l, '[]').           bracket(']', r, '[]').
bracket('{', l, '{}').           bracket('}', r, '{}').

% transform a raw token into its final form
maketoken(var(Namestring), vns(Ptr), Sym_tab) :-
      makeptr(Namestring, Ptr, Sym_tab).
maketoken(id(Namestring), Token, _) :-
      pname(Name, Namestring), make_ff_or_id(Name, Token).
maketoken(qid(Namestring), id(Name), _) :-
      pname(Name, Namestring).
maketoken(num([- | Digits]), vns(N), _) :-
      pnamei(N1, Digits), sum(N, N1, 0).
maketoken(num(Digits), vns(N), _) :- pnamei(N, Digits).
maketoken(str(Chars), vns(Chars), _).
maketoken(Token, Token, _).      % br(_,_) and bar and dot

% variables are kept in a symbol table (an open list)
makeptr(['_'], _, _).      % no search - an anonymous variable
makeptr(Nmstr, Ptr, Sym_tab) :- look_var(var(Nmstr, Ptr), Sym_tab).

% look-up
look_var(Item, [Item | Sym_tab]).
look_var(Item, [_ | Sym_tab]) :- look_var(Item, Sym_tab).

make_ff_or_id(Name, ff(Name, Types, Prior)) :-
      'FF'(Name, Types, Prior).
make_ff_or_id(Name, id(Name)).

% :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
% - - - - - -              GRAMMAR RULE PREPROCESSOR              - - - - - -
% :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

transl_rule(Left, Right, Clause) :-
      two_ok(Left, Right),
      isolate_lhs_t(Left, Nont, Lhs_t),
      connect(Lhs_t, Outpar, Finalvar),
      expand(Nont, Initvar, Outpar, Head),
      makebody(Right, Initvar, Finalvar, Body, Alt_flag),
      do_clause(Body, Head, Clause).

do_clause(true, Head, Head) :- !.
do_clause(Body, Head, :-(Head, Body)).

% Lhs_t is a list (possibly empty) of lefthand side terminals
isolate_lhs_t(','(Nont, Lhs_t), Nont, Lhs_t) :-
      ';'(nonvarint(Nont), rulerror(varint)),
      ';'(isclosedlist(Lhs_t), rulerror(ter)), !.
isolate_lhs_t(Nont, Nont, []).

% fail if not a closed list
isclosedlist(L) :- check(iscll(L)).
iscll(L) :- var(L), !, fail.
iscll([]).
iscll([_ | L]) :- iscll(L).

% connect terminals to the nearest nonterminal's input parameter
% (actually, "open" a closed list)
connect([], Nextvar, Nextvar).
connect([Tsym | Tsyms], [Tsym | Outpar], Nextvar) :-
      connect(Tsyms, Outpar, Nextvar).

% - - - translate the righthand side (loop over alternatives)
% in alternatives, each righthand side is preceded by a dummy
% nonterminal, as defined by   ' dummy' --> [].    (since terminals
% are appended to input parameters, the input parameter of a common
% lefthand side must be a variable)
makebody(';'(Alt, Alts), Initvar, Finalvar,
         ';'(','(' dummy'(Initvar, Nextvar), Alt_b), Alt_bs), _) :-
      !, two_ok(Alt, Alts),
      makeright(Alt, Nextvar, Finalvar, Alt_b),
      makebody(Alts, Initvar, Finalvar, Alt_bs, alt).
makebody(Right, Initvar, Finalvar, Body, Alt_flag) :-
      var(Alt_flag), !,       % only one alternative
      makeright(Right, Initvar, Finalvar, Body).
makebody(Right, Initvar, Finalvar,
         ','(' dummy'(Initvar, Nextvar), Body), alt) :-
      makeright(Right, Nextvar, Finalvar, Body).

% - - - translate one alternative
makeright(','(Item, Items), Thispar, Finalvar, T_item_items) :-
      !, two_ok(Item, Items),
      transl_item(Item, Thispar, Nextvar, T_item),
      makeright(Items, Nextvar, Finalvar, T_items),
      combine(T_item, T_items, T_item_items).
makeright(Item, Thispar, Finalvar, T_item) :-
      transl_item(Item, Thispar, Finalvar, T_item).

combine(true, T_items, T_items) :- !.
combine(T_item, true, T_item) :- !.
combine(T_item, T_items, ','(T_item, T_items)).

% - - - translate one item (sure to be a functor-term)
transl_item(Terminals, Thispar, Nextvar, true) :-
      isclosedlist(Terminals),
      !, connect(Terminals, Thispar, Nextvar).
% conditions (the cut and others)
transl_item(!, Thispar, Thispar, !) :- !.
transl_item('{}'(Cond), Thispar, Thispar, call(Cond)) :- !.
% bad list of terminals (missed the first clause)
transl_item([_ | _], _, _, _) :- rulerror(ter).
% a nested alternative
transl_item(';'(X, Y), Thispar, Nextvar, Transl) :-
      !, makebody(';'(X, Y), Thispar, Nextvar, Transl, _).
% finally, a regular nonterminal
transl_item(Nont, Thispar, Nextvar, Transl) :-
      expand(Nont, Thispar, Nextvar, Transl).

% add input parameter and output parameter
expand(Nont, In_par, Out_par, Call) :-
      =..(Nont, [Fun | Args]),
      =..(Call, [Fun, In_par, Out_par | Args]).

% - - - error handling
two_ok(X, Y) :- nonvarint(X), nonvarint(Y), !.
two_ok(_, _) :- rulerror(varint).

rulerror(Message) :-
      nl, display('+++ Error in this rule: '), mes(Message), nl,
      tagfail(transl_rule(_, _, _)).
% diagnostics are only very brief (and not too informative ...)
mes(varint) :- display('variable or integer item.').
mes(ter) :- display('terminals not in a closed list.').

% - - - initiate grammar processing
phrase(Nont, Terminals) :-
      nonvarint(Nont), !,
      expand(Nont, Terminals, [], Init_call),
      call(Init_call).
phrase(N, T) :- error(phrase(N, T)).

' dummy'(X, X).

                         % ***************************
                         % ***************************
                         % ***    L I B R A R Y    ***
                         % ***************************
                         % ***************************
% :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
% - - - - - -                 =..  (read as "univ")               - - - - - -
% :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

=..(X, Y) :- var(X), var(Y), !, error(=..(X, Y)).
=..(Num, [Num]) :- integer(Num), !.
=..(Term, [Fun | Args]) :-
      setarity(Term, Args, N),
      functor(Term, Fun, N),           % this works both ways
      not(integer(Fun)),               % we dont't want e.g. 17(X)
      setargs(Term, Args, 0, N).       % this works both ways, too

setarity(Term, Args, N) :- var(Term), !, length(Args, N).
         % notice that bad Args give an error in  l e n g t h
setarity(_, _, _).      % Arity will be set by  f u n c t o r  in =..

% both numeric parameters are given,
% the loop stops when the third reaches the fourth
% (works both ways because  a r g  does)
setargs(_, [], N, N) :- !.
setargs(Term, [Arg | Args], K, N) :-
      sum(K, 1, K1), arg(K1, Term, Arg),
      setargs(Term, Args, K1, N).

% find the length of a closed list; error if not closed
length(List, N) :- length(List, 0, N).

% this is a tail-recursive formulation of length
length(L, _, _) :- var(L), !, error(length(L, _)).
length([], N, N) :- !.
length([_ | List], K, N) :-
      !, sum(K, 1, K1), length(List, K1, N).
length(Bizarre, _, _) :- error(length(Bizarre, _)).

% bind every variable to a distinct 'V'(N)
numbervars('V'(N), N, NextN) :- !, sum(N, 1, NextN).
numbervars('V'(_), N, N) :- !.
numbervars(X, N, N) :- integer(X), !.
numbervars(X, N, NextN) :- numbervars(X, 1, N, NextN).

numbervars(X, K, N, NextN) :-
      arg(K, X, A), !, numbervars(A, N, MidN),
      sum(K, 1, K1), numbervars(X, K1, MidN, NextN).
numbervars(_, _, N, N).

% :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
% - - - - - -           PREDEFINED "FIX" FUNCTORS ETC.            - - - - - -
% :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

% op has been defined as a system routine, together with 'FF' and delop

:- op(1000, xfy, ',').  % ordered according to probable frequency
:- op(1200, xfx, :- ).
:- op(1200, fx,  :- ).
:- op(1100, xfy, ';').
:- op( 900, fy,  not).
:- op( 700, xfx, =  ).
:- op( 700, xfx, is ).
:- op(1200, xfx, -->).
:- op( 500, yfx, +  ).
:- op( 500, fx,  +  ).
:- op( 500, yfx, -  ).
:- op( 500, fx,  -  ).
:- op( 400, yfx, *  ).
:- op( 400, yfx, /  ).
:- op( 300, xfx, mod).
:- op( 700, xfx, <  ).
:- op( 700, xfx, =< ).
:- op( 700, xfx, >  ).
:- op( 700, xfx, >= ).
:- op( 700, xfx, =:=).
:- op( 700, xfx, =\=).
:- op( 700, xfx, @< ).
:- op( 700, xfx, @=<).
:- op( 700, xfx, @> ).
:- op( 700, xfx, @>=).
:- op( 700, xfx, =..).
:- op( 700, xfx, == ).
:- op( 700, xfx, \==).

% test for binary and instantiate Assoc
binary(yfy, a(_)).         % arbitrarily associative
binary(xfy, a(r)).         % right associative
binary(yfx, a(l)).         % left associative
binary(xfx, na(_)).        % non-associative
% test for unary, instantiate Kind and Assoc
unary(fy, pre, a(r)).      % right associative
unary(fx, pre, na(r)).     % right non-associative
unary(yf, post, a(l)).     % left associative
unary(xf, post, na(l)).    % left non-associative

% :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
% - - - - - -          EVALUATE AN ARITHMETIC EXPRESSION          - - - - - -
% :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

is(N, N) :- integer(N), !.
is(Val, +(A, B)) :-
      !, is(Av, A), is(Bv, B), sum(Av, Bv, Val).
is(Val, -(A, B)) :-
      !, is(Av, A), is(Bv, B), sum(Bv, Val, Av).
is(Val, *(A, B)) :-
      !, is(Av, A), is(Bv, B), prod(Av, Bv, 0, Val).
is(Val, /(A, B)) :-
      !, is(Av, A), is(Bv, B), prod(Bv, Val, _, Av).
is(Val, mod(A, B)) :-
      !, is(Av, A), is(Bv, B), prod(Bv, _, Val, Av).
is(Val, +(A)) :- !, is(Val, A).
is(Val, -(A)) :- !, is(Av, A), sum(Val, Av, 0).
is(N, [N]) :- integer(N).
% otherwise  f a i l

% - - - - - - EVALUATE AN ARITHMETIC RELATION - - - - - -
=:=(X, Y) :- is(Val, X), is(Val, Y).
<(X, Y)   :- is(Xv, X), is(Yv, Y), less(Xv, Yv).
=<(X, Y)  :- is(Xv, X), is(Yv, Y), not(less(Yv, Xv)).
>(X, Y)   :- is(Xv, X), is(Yv, Y), less(Yv, Xv).
>=(X, Y)  :- is(Xv, X), is(Yv, Y), not(less(Xv, Yv)).
=\=(X, Y) :- not(=:=(X, Y)).

% :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
% - - - - - -               PERFECT EQUALITY OF TERMS             - - - - - -
% :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

==(T1, T2) :- var(T1), var(T2), !, eqvar(T1, T2).
==(T1, T2) :- check(==?(T1, T2)).

\==(T1, T2) :- not(==?(T1, T2)).

==?(T1, T2) :-
      integer(T1), integer(T2), !, =(T1, T2).
==?(T1, T2) :-
      nonvarint(T1), nonvarint(T2),
      functor(T1, Fun, Arity), functor(T2, Fun, Arity),
      equalargs(T1, T2, 1).

equalargs(T1, T2, Argnumber) :-
      arg(Argnumber, T1, Arg1), arg(Argnumber, T2, Arg2),
            % arg fails given too large a number
      !, ==(Arg1, Arg2), sum(Argnumber, 1, Nextnumber),
      equalargs(T1, T2, Nextnumber).
equalargs(_, _, _).

% :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
% - - - - - -      assert, asserta, assertz, retract, clause      - - - - - -
% :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
% - - - add a clause (using built-in assert/3)
assert(Cl) :- asserta(Cl).
asserta(Cl) :-
      nonvarint(Cl), convert(Cl, Head, Body), !,
      assert(Head, Body, 0).
asserta(Cl) :- error(asserta(Cl)).

assertz(Cl) :-
      nonvarint(Cl), convert(Cl, Head, Body), !,
      assert(Head, Body, 32767).       % i.e. MAXINT in this implementation
assertz(Cl) :- error(assertz(Cl)).

% convert the external form of a Body into a dotted list
convert(:-(Head, B), Head, Body) :- conv_body(B, Body).
convert(Unit_cl, Unit_cl, []).

% this procedure works both ways
conv_body(B, [call(B)]) :- var(B), !.
conv_body(true, []).
conv_body(B, Body) :- conv_b(B, Body).

conv_b(B, [Body]) :- var(B), !, conv_call(B, Body).
conv_b(','(C, B), [Call | Body]) :-
      !, conv_call(C, Call), conv_b(B, Body).
conv_b(Call, [Call]).      % sure to be no variable

% interpreter can process variable calls only within  c a l l
conv_call(C, call(C)) :- var(C), !.
conv_call(C, C).

% - - - remove a clause (this procedure is backtrackable)
retract(Cl) :-
      nonvarint(Cl), convert(Cl, Head, Body), !,
      functor(Head, Fun, Arity), remcls(Fun, Arity, 1, Head, Body).
retract(Cl) :- error(retract(Cl)).

% ultimate failure if N too big (retract/3 fails)
remcls(Fun, Arity, N, Head, Body) :-
   clause(Fun, Arity, N, N_head, N_body),
   remcls(Fun, Arity, N, N_head, Head, N_body, Body).

remcls(Fun, Arity, N, Head, Head, Body, Body) :-
   retract(Fun, Arity, N).
% user's backtracking resumes  r e t r a c t  here
% (after removing the Nth clause the next becomes Nth)
remcls(Fun, Arity, N, N_head, Head, N_body, Body) :-
      check(=(N_head, Head)), check(=(N_body, Body)),
      !, remcls(Fun, Arity, N, Head, Body).
remcls(Fun, Arity, N, _, Head, _, Body) :-
      sum(N, 1, N1), remcls(Fun, Arity, N1, Head, Body).

% - - - generate nondeterministically all clauses whose head
%       and body match the parameters of  c l a u s e
clause(Head, Body) :-
      nonvarint(Head), !, functor(Head, Fun, Arity),
      gencls(Fun, Arity, 1, Head, Body).
clause(Head, Body) :- error(clause(Head, Body)).

% generate: ultimate failure if N too big (clause/5 fails)
gencls(Fun, Arity, N, Head, Body) :-
      clause(Fun, Arity, N, N_head, N_body),
      gencls(Fun, Arity, N, N_head, Head, N_body, Body).

% fail if N_head does not match Head,
% or if N_body converted does not match Body
gencls(_, _, _, N_head, N_head, N_body, Body) :-
      conv_body(Body, N_body).
% user's backtracking resumes  c l a u s e  here
gencls(Fun, Arity, N, _, Head, _, Body) :-
      sum(N, 1, N1), gencls(Fun, Arity, N1, Head, Body).

% :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
% - - - - - -                       L I S T I N G                 - - - - - -
% :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
% list procedures determined by the parameter (listing/1)
%                    or all user's procedures (listing/0)
listing :-
   proc(Head), listproc(Head), nl, fail.
listing.    % catch the final fail from  p r o c

listing(Fun) :- atom(Fun), !, listbyname(Fun).
listing(/(Fun, Arity)) :-
      atom(Fun), integer(Arity), =<(0, Arity), !,
      functor(Head, Fun, Arity), listproc(Head).
listing(L) :-
      isclosedlist(L), listseveral(L), !.
listing(X) :- error(listing(X)).
      % isclosedlist - cf. grammar rule preprocessor

listseveral([]).
listseveral([Item | Items]) :-
      listing(Item), listseveral(Items).

% all procedures with this name
listbyname(Fun) :-
      proc(Head), functor(Head, Fun, _),
      listproc(Head), nl, fail.
listbyname(_).    % succeed

% one procedure
listproc(Head) :-
      clause(Head, Body),
      writeclause(Head, Body), wch(.), nl, fail.
listproc(_).      % succeed

writeclause(Head, Body) :-
      not(var(Body)), =(Body, true), !, writeq(Head).
writeclause(Head, Body) :- writeq(:-(Head, Body)).

% :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
% - - - - - -                        W R I T E                    - - - - - -
% :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

write(Term) :- side_effects(outterm(Term, noq)).

% writeq encloses in quotes all identifiers except words,
% symbols and solochars (not coinciding with "fix" functors)
writeq(Term) :- side_effects(outterm(Term, q)).

writetext([Ch | Chs]) :- !, wch(Ch), writetext(Chs).
writetext([]).

outterm(T, Q) :- numbervars(T, 1, _), outt(T, fd(_,_), Q).

% the real job is done here
outt(X, _, _) :- var(X), !, wch('_').
                  % applies only to anonymous variables read in by
                  % the "kernel" reader
outt('V'(N), _, _) :- integer(N), !, wch('X'), display(N).
                  % C A U T I O N :  outt is unable to write 'V'(Integer)
outt(Term, _, _) :- integer(Term), display(Term), !.
% the second parameter specifies a context for "fix" functors:
% the nearest external functor and Term's position
% (to the left or to the right of the external functor)
outt(Term, Context, Q) :-
      =..(Term, [Name | Args]),
      outfun(Name, Args, Context, Q).

% - - - output a functor-term
%   -   as a "fix" term
outfun(Name, Args, Context, Q) :-
      isfix(Name, Args, This_ff, Kind), !,
      outff(Kind, This_ff, [Name | Args], Context, Q).
%   -   as a list
outfun(., [Larg, Rarg], _, Q) :-
      !, outlist([Larg | Rarg], Q).
%   -   as a normal functor-term
outfun(Name, Args, _, Q) :-
      outname(Name, Q), outargs(Args, Q).

% isfix constructs a pair  ff(Prior, Associativity), and
% 'in' or 'pre' or 'post' (fails if not a "fix" functor)
isfix(Name, [_, _], ff(Prior, Assoc), in) :-
      'FF'(Name, Types, Prior), mk_bin(Types, Assoc).
isfix(Name, [_], ff(Prior, Assoc), Kind) :-
      'FF'(Name, Types, Prior), mk_un(Types, Kind, Assoc).

% Bintype (if any) is before Untype (if any)
mk_bin([Bintype | _], Assoc) :- binary(Bintype, Assoc).
mk_un([Untype], Kind, Assoc) :- unary(Untype, Kind, Assoc).
mk_un([_, Untype], Kind, Assoc) :- unary(Untype, Kind, Assoc).
% tests - see  o p

% - - - output a "fix" term (this outff has 5 parameters)
outff(Kind, This_ff, NameArgs, Context, Q) :-
      agree(This_ff, Context), !,
      outff(Kind, This_ff, NameArgs, Q).
outff(Kind, This_ff, NameArgs, _, Q) :-
      wch('('), outff(Kind, This_ff, NameArgs, Q), wch(')').

% agree helps avoid (some) unnecessary brackets around the term
agree(_, fd(Ext_ff, _)) :- var(Ext_ff).
agree(ff(Prior1, _), fd(ff(Prior2, _), _)) :-
      stronger(Prior1, Prior2).        % cf. the parser
agree(ff(Prior, a(Dir)), fd(ff(Prior, a(Dir)), Dir)).

% output the functor and the arguments (this outff has 4 parameters)
outff(in, This_ff, [Name, Larg, Rarg], Q) :-
      outt(Larg, fd(This_ff, l), Q),
      outfn(Name, ' '), outt(Rarg, fd(This_ff, r), Q).
outff(pre, This_ff, [Name, Arg], Q) :-
      outfn(Name, ' '), outt(Arg, fd(This_ff, r), Q).
outff(post, This_ff, [Name, Arg], Q) :-
      outt(Arg, fd(This_ff, l), Q), outfn(Name, ' ').

% output functor's name enclosed in Encl
% if Encl is not a space, double ocurrences of Encl  w i t h i n  Name
outfn(Name, ' ') :- !, wch(' '), display(Name), wch(' ').
outfn(Name, Encl) :- wch(Encl), pname(Name, NmString),
      outfn1(NmString, Encl), wch(Encl).

outfn1([], _) :- !.
outfn1([E | T], E) :- !, wch(E), wch(E), outfn1(T, E).
outfn1([C | T], E) :- wch(C), outfn1(T, E).

% - - - print a name (in quotes, if necessary)
outname(Name, noq) :- !, display(Name).
outname(Name, q) :-
      'FF'(Name, _, _), !, outfn(Name, '''').
outname(Name, q) :-
      pname(Name, Namestring),
      check(noq(Namestring)), !, display(Name).
outname(Name, q) :- outfn(Name, '''').

noq([Ch | String]) :- wordstart(Ch), isword(String).
noq([Ch]) :- solochar(Ch).
noq(['[', ']']).
noq([Ch | String]) :- symch(Ch), issym(String).

isword([]).
isword([Ch | String]) :- alphanum(Ch), isword(String).
issym([]).
issym([Ch | String]) :- symch(Ch), issym(String).

% - - - output a list of arguments (cf. outfun)
outargs([], _) :- !.
outargs(Args, Q) :-
      fake(Context), wch('('), outargs(Args, Context, Q), wch(')').

outargs([Last], Context, Q) :- !, outt(Last, Context, Q).
outargs([Arg | Args], Context, Q) :-
      outt(Arg, Context, Q), display(', '), outargs(Args, Context, Q).

% commas are used to delimit list items, so we must bracket commas
% w i t h i n  items (it's a trick: we depend on ',' having
%   the priority 1000 and being associative)
fake(fd(ff(1000, na(_)), _)).

% - - - output a list in square brackets (cf. outfun - the main
%   functor is the dot, and the list cannot be empty)
outlist([First | Tail], Q) :-
         fake(Context), wch('['), outt(First, Context, Q),
         outlist(Tail, Context, Q), wch(']').

outlist([], _, _) :- !.
outlist([Item | Items], Context, Q) :-
      !, display(', '), outt(Item, Context, Q),
      outlist(Items, Context, Q).
% the bar and the closing item (still bracketed if it contains commas)
outlist(Closing, Context, Q) :-
      display(' | '), outt(Closing, Context, Q).

                      % *********************************
                      % *********************************
                      % ***    T R A N S L A T O R    ***
                      % *********************************
                      % *********************************

% read a program upto  "end."  and translate it into "kernel" form
translate(Infile, Outfile) :-
      see(Infile), tell(Outfile),
      nl, repeat,
         read(Clause, OrgST), put(Clause, OrgST), nl, =(Clause, end), !,
      seen, told, see(user), tell(user).

% - - - produce and output the translation of one clause
put(:-(Head, Body), OrgST) :-
      !, puthead(Head, Sym_tab), putbody(Body, Sym_tab),
      put_varnames(OrgST, Sym_tab, 0).
put(-->(Left, Right), OrgST) :-
      !, tag(transl_rule(Left, Right, :-(Head, Body))),
      puthead(Head, Sym_tab), putbody(Body, Sym_tab),
      put_varnames(OrgST, Sym_tab, 0).
put(:-(Goal), OrgST) :-
      !, putbody(Goal, Sym_tab), wch(#), nl,
      put_varnames(OrgST, Sym_tab, 0),
      once(Goal).    % a failure here wouldn't matter (cf. translate)
put(end, _) :- !, putbody(seen, _), wch(#), nl.
      % this is for security
put('e r r', _) :- !.
put(Unitclause, OrgST) :- puthead(Unitclause, Sym_tab), putbody(true, _),
      put_varnames(OrgST, Sym_tab, 0).

% - - - put a head call (it must be a functor-term)
puthead(Head, Sym_tab) :-
      nonvarint(Head), !, putterm(Head, Sym_tab).
puthead(Head, _) :- transl_err(Head).

% - - - put a list of calls and [] at the end
putbody(Body, Sym_tab) :-
      punct(:), conv_body(Body, B), !, putbody_c(B, Sym_tab).
               % see assert etc. for  c o n v _ b o d y

putbody_c([], _) :- !, display([]).
putbody_c([Term | Terms], Sym_tab) :-
      not(integer(Term)), !, putterm(Term, Sym_tab),
      punct(.), putbody_c(Terms, Sym_tab).
putbody_c([Term | _], _) :- transl_err(Term).

punct(Ch) :- wch(' '), wch(Ch), nl, display('   ').

% - - - put a term (with infix dots, and canonical otherwise)
putterm(Term, Sym_tab) :-
      var(Term), !, lookup(Term, Sym_tab, -1, N),
      wch(:), display(N).
putterm(Term, _) :- integer(Term), !, display(Term).
putterm([Head | Tail], Sym_tab) :-
      !, putterm_inlist(Head, Sym_tab),
      display(' . '), putterm(Tail, Sym_tab).
putterm(Term, Sym_tab) :-
      =..(Term, [Name | Args]), outfn(Name, ''''),    % cf.  w r i t e
      putargs(Args, Sym_tab).

% Sym_tab is an open list of pairs  vn(Variable, Number)
% (this formulation helps avoid too many additions)
lookup(V, S_t_end, PreviousN, N) :-
      var(S_t_end), !, sum(PreviousN, 1, N),
      =(S_t_end, [vn(V, N) | New_S_t_end]).
lookup(V, [vn(CurrV, CurrN) | _], _, CurrN) :-
      eqvar(V, CurrV), !.
lookup(V, [vn(_, CurrN) | S_t_tail], _, N) :-
      lookup(V, S_t_tail, CurrN, N).

% arguments - nothing, or a list of terms in parentheses
putargs([], _) :- !.
putargs(Args, Sym_tab) :-
      wch('('), putarglist(Args, Sym_tab), wch(')').

putarglist([Arg], Sym_tab) :- !, putterm(Arg, Sym_tab).
putarglist([Arg | Args], Sym_tab) :-
      putterm(Arg, Sym_tab), display(', '),
      putarglist(Args, Sym_tab).

% - - - a list within a list must be enclosed in parentheses
putterm_inlist(Term, Sym_tab) :-
      nonvarint(Term), =(Term, [_ | _]), !,
      wch('('), putterm(Term, Sym_tab), wch(')').
putterm_inlist(Term, Sym_tab) :- putterm(Term, Sym_tab).

% - - - error handling (only one error is discovered by translate)
transl_err(X) :-
      nl, display('+++ Bad head or call: '), display(X), nl, fail.

% - - - output names of source variables paired with numbers
put_varnames(_, EndOfST, _) :- var(EndOfST), !.
put_varnames(OrgST, [vn(Inst, Num) | RestOfST], Count) :-
      find_varname(Inst, OrgST, Num, Name), nextline(Count),
      wch(' '), display(Num), wch(' '), writetext(Name), wch(','),
      sum(Count, 1, NextCount), put_varnames(OrgST, RestOfST, NextCount).

find_varname(_, EndOrgST, Num, ['X' | Digits]) :-
      var(EndOrgST), !, pnamei(Num, Digits).
find_varname(Inst, [var(Name, Inst1) | _ ], _, Name) :-
      eqvar(Inst, Inst1), !.
find_varname(Inst, [_ | RestOrgST], Num, Name) :-
      find_varname(Inst, RestOrgST, Num, Name).

nextline(N) :- prod(6, _, 0, N), !, nl, display('   %%').
nextline(_).

%::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
%- - - - - - - - - protect / unprotect all of the library - - - - - - - - - -
%::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
protect :-
      proc(Proc), functor(Proc, Name, Arity), protect(Name, Arity), fail.
protect :- display('All predicates protected.'), nl.

unprotect :-
      proc(Proc), functor(Proc, Name, Arity), unprotect(Name, Arity), fail.
unprotect :- display('All predicates un-protected.'), nl.

% ok, monitor loaded - protect it (the system will start up the 'ear' goal)

:- grf_mse_hide, txt_mode, protect, seen.